perm filename MUS3.F4[P11,LCS] blob
sn#587480 filedate 1981-05-18 generic text, type T, neo UTF8
C**** MUS3.F4 ********
C** LINES, LINED, EDIT, MOVIT, OUTLMT, GETPTS, GUPDAT, DELETE, STFCH,COPYIT,CPYIT
SUBROUTINE LINES(A,B,L)
COMMON/DST/BB,CC /SIZ/RSZ,JCEN,KCEN
COMMON/DL/IXRX,SAVER,AA /PLTR/IPLT,RHT,DIS
COMMON R2,JA,CENTR,JB,RJQ(20),JQ(20)
COMMON /DPY/JJ(4000),MEDIT,IGO /DPTR/WDS(350)
EQUIVALENCE (JJ2,JJ(2))
DATA BB/.008/,CC/3.5/
C LINED: 0 ;WE GET HERE FROM FILLMS -- NEEDED FOR DISTORTION SYSTEM
GO TO 23
22 IF(JQ(1).NE.0)GO TO 23
C USE P11 > 0 FOR DISTORTION.
C P11 IS BB (DIST) P12 IS CC(DST+1)
C DST=.005 DST+1=2.2 (IN FILMSS.FAI) (.0044, 3.5 IN 'ADVICE')
IF(CC.EQ.1000)GO TO 23
B=B*(CC-BB*ABS(A))
C BB IS DST, CC IS DST+1
23 IF(JJ2.GT.3990)RETURN
C AVOID OVERLOADING DPY BUFFER(4000)
M=A*RSZ
N=B*RSZ
IF(RSZ.LE.0.8571)GO TO 3
C; SO WE CAN ZOOM UP,DOWN,LEFT,RIGHT AND ANY SIZE MOVE T,[=0.8571]
M=M-JCEN
N=N-KCEN
3 CALL CLIP(M,N,L)
END
SUBROUTINE LINED(A,B,L)
CALL LINES(A,B,L)
END
SUBROUTINE EDIT(JJA)
COMMON/ALF/INP(72),ML /UPDWN/ RL,UD
COMMON /SC/JL,LJ,MK
1 ,ISKP,XMINUS,N,REXP,LK,NNUM,JM,JN,DBST,NFLG,IXX,ISEMI,QQ
1 ,RVX(50),IAMP,A,RRN,B,MODE,IBLA
COMMON R2,JA,CENTR,J2,RJQ(20),JQ(20)
COMMON/RRJJ/RJJ2,RJJ(20)
EQUIVALENCE (RVX1,RVX(1)),(RVX2,RVX(2)),(RVX4,RVX(4)),(RJ7,RJJ(5))
1,(RVX3,RVX(3)),(RJ6,RJJ(4)),(RJ9,RJJ(7)),(R3,RJQ(1)),(RJ8,RJJ(6))
1,(RJ5,RJJ(3)),(RJ10,RJJ(8)),(INP2,INP(2)),(INP20,INP(20))
JN=-1
C THIS IS FLAG IN SCANR
INP20=ISEMI
C SETS LIMIT IN SCANR
ML=1
RVX2=0
RVX4=0
C E=EDIT(55), C=COPY(2222), X=EXIT(222), DE=DEL(99), LP=LTPN
CALL SCANR
JN=0
R2=RVX2
IF(RVX1.GT.10.)GO TO 7
JA=0
IF(RVX2.NE.0)GO TO 8
IF(INP2.EQ.'P')GO TO 5
RVX2=RL
IF(RVX1.GT.2)RVX2=UD
C STORES RT-LFT OR UP-DOWN INFO
GO TO 8
C FOR LIGHT PEN MOVING
7 JA=RVX1
IF(JA.EQ.99)R2=0
IF(R2.NE.0)RETURN
IF(JA.NE.55)RETURN
5 CALL LPEN(R3,R2,K)
C ↑↑↑ K NOT USED!
IF(JA.EQ.0)CALL EXCH(R2,R3)
RVX1=2.
RVX2=R3-RJJ(1)
RVX3=3.
RJQ(2)=0
RJJ2=R2
C SO JD WILL BE 0 IN MAIN PROG.
C FOR EDIT MODE
8 IF(JA.EQ.55)RETURN
IF(INP2.EQ.'P')GO TO 17
IF(RVX1.GT.2)GO TO 117
RL=RVX2
IF(RVX4.NE.0)UD=RVX4
GO TO 17
117 IF(RVX4.NE.0)RL=RVX4
UD=RVX2
17 R2=.00001
JA=0
K=RVX1
857 IF(K.LE.0)GO TO 1
IF(K.GE.5)GO TO 2
C -- CATCHES SOME ERRORS.
GO TO (1,2,3,4),K
4 RVX2=-RVX2
C SKIP IF NOT CODE 4
3 IF(JJA.NE.4)GO TO 31
IF(RJ6.NE.0)GO TO 31
C IGNORE BAR LINES -- IF(R5.EQ.0.AND.R6.EQ.0)GO TO 856
IF(RJ5.EQ.0)GO TO 856
31 CALL MVBEAM(RJJ,0,2,2,RVX2)
C MOVES UP AND DOWN. HANDLES MINIS, ETC.
IF(JJA.LT.4)GO TO 856
IF(JJA.GT.6)GO TO 856
C I THINK R2 MUST BE NON-ZERO TO WORK IN EDIT MODE?
12 IF(RJ5.EQ.50.OR.RJ5.EQ.150)GO TO 856
C 50,150=CRESC.-DECRESC.
RJ5=RJ5+RVX2
C MOVES 5TH PARAM UP OR DOWN
GO TO 856
1 RVX2=-RVX2
2 R2=RVX2
856 IF(RVX4.EQ.0)GO TO 858
K=RVX3
RVX2=RVX4
RVX4=0
GO TO 857
858 IF(R2.EQ..00001)GO TO 7515
IF(JJA.LT.5)GO TO 477
IF(JJA.LE.8)GO TO 5515
477 IF(JJA.NE.4)GO TO 7515
IF(RJ6.EQ.0.AND.RJ5.EQ.0)GO TO 7515
C RARE CASES MIGHT BE FOUND! USING P7≠0
C ABOVE FOR P1=6 (BEAMS, SLURS, LINES)
5515 IF(RJ6.NE.0)RJ6=RJ6+R2
IF(JJA.NE.6)GO TO 7515
IF(RJ9.EQ.0)GO TO 7515
IF(RJ7.GT.0)GO TO 88
CCC IF(RJ10.NE.0)GO TO EDX1
IF(RJ9.GT.0)GO TO 7514
88 IF(RJ8.EQ.0)GO TO 7515
IF(RJ8.GE.0)RJ8=RJ8+R2
7514 IF(RJ9.GE.0)RJ9=RJ9+R2
C RJ9(P9) IS LOC. OF INNER NOTE IN BEAM RANGE. SKIPS NUMBERS IN P9.
7515 RJJ(1)=R2+RJJ(1)
END
C****** SUBRS MOVIT, OUTLMT, GETPTS, GUPDAT, DELETE, STFCH,COPYIT,CPYIT
C--- FROM MOVE.FAI=GETPTS,MOVIT,COPYIT,STFCH,DELETE
SUBROUTINE MOVIT(RN,NP,R4,R5,R8,R9)
DIMENSION NP(1),RN(1)
COMMON /KJY/ NO,J
RDIS=(R9-R8)/(R5-R4)
DO 1 K=1,J
L=NP(K)
RA=RN(L)
IF(OUTLMT(R4,R5,RA))GO TO 1
IF(R9.NE.0)RA=(RA-R4)*RDIS
RN(L)=R8+RA
1 CONTINUE
END
FUNCTION OUTLMT(A,B,R)
C TELLS IF POINT IS WITHIN BOUNDS OF A-B (PUT THIS INTO MACRO)
OUTLMT=-1.
IF(R.LT.A)RETURN
IF(R.GT.B)RETURN
OUTLMT=0
END
SUBROUTINE GETPTS(NN)
C NN IS FIRST ITEM TO LOOK AT
INTEGER PWDS
COMMON/XRN/RN(1) /KJY/ K,J /POSI/STFF(8),JJ2
COMMON R2,JA,CENTR,J2,RJQ(18),RX6,JR,L,RDIS,VY,JQ(17)
1/PTR/PWDS(1) /RINP/R(500),N(350),NP(250) /LIMIT/LIM,ITEM
EQUIVALENCE (R4,RJQ(2)),(R5,RJQ(3)),(R6,RJQ(4))
J=0
K=0
C J AND K ARE COUNTERS FOR N AND NP ARRAYS.
DO 1 M=NN,ITEM
L=PWDS(M)
RY=RN(L+1)
IF(R2.GE.8)GO TO 3
C >=8 MEANS LOOK AT ALL STAVES
IF(R2.NE.RN(L+2))GO TO 1
C SKIP IF NOT RIGHT STAFF NUM.
3 IF(R6.LE.0)GO TO 9
C CHECK CODE NUM
IF(R6.NE.RY)GO TO 1
9 IF(OUTLMT(R4,R5,RN(L+3)))GO TO 2
C IN LIMITS?
CALL GUPDAT(M,L,3)
C GO PUT AWAY POINTER TO P3 OF THIS ITEM
K=K+1
NP(K)=L
C NP SAVES POINTER TO P3 FOR USE IN JUSTIFY ROUTINE
2 CNT=RN(L)
C GET THE WD CNT
IF(RY.EQ.2)GO TO 8
C FOR 'CENTERED' RESTS
IF(RY.LT.4)GO TO 1
IF(RY.GT.7)GO TO 1
IF(RY.EQ.6)GO TO 6
C TWO-ENDED ITEM?
7 IF(CNT.GT.3)GO TO 5
GO TO 1
6 IF(CNT.LT.8)GO TO 8
IF(RN(L+7).LT.0)GO TO 8
IF(RN(L+10).EQ.0)GO TO 8
IF(RN(L+8).LE.0)GO TO 8
C IGNORE P8 IF IT IS 0 OR -
IF(OUTLMT(R4,R5,RN(L+8)))GO TO 8
C IN LIMITS?
CALL GUPDAT(M,L,8)
C PUT AWAY POINTER TO P8 FOR THIS BEAM
8 IF(CNT.LT.7)GO TO 5
IF(RN(L+9).LE.0)GO TO 5
C WON'T LOOK AT NEG. POS.
IF(RY.EQ.2)GO TO 10
C (NEW REST CENTERING)
IF(RN(L+8).NE.0)GO TO 10
IF(RN(L+7).GE.0)GO TO 5
C USE R9 IF R9<0 AND (R8≠0 OR R7<0)
10 IF(OUTLMT(R4,R5,RN(L+9)))GO TO 1
C IN LIMITS?
CALL GUPDAT(M,L,9)
5 IF(RY.EQ.2)GO TO 1
IF(OUTLMT(R4,R5,RN(L+6)))GO TO 1
C IN LIMITS?
CALL GUPDAT(M,L,6)
C PUT AWAY POINTER TO P6 FOR ALL 2-SIDED ITEMS.
1 CONTINUE
END
SUBROUTINE GUPDAT(M,L,KK)
COMMON /KJY/ K,J /POSI/STFF(8),JJ2 /RINP/R(500),N(350),NP(250)
J=J+1
N(J)=L+KK
C SETS UP POINTERS FOR USE IN MOVES, ETC.
IF(M.LT.JJ2)JJ2=M
END
SUBROUTINE DELETE
IMPLICIT INTEGER(A-Q,S-Z)
COMMON/DL/X22,SAVER,NAME /XRN/RN(1)
COMMON R2,JA,CENTR,J2,RJQ(20),JQ(15),R6,DEL,X,JY,K
COMMON/PTR/PWDS(1) /LIMIT/LIM,ITEM,L,I,IX
1 /DPY/ST(4000),MEDIT,IGO /DPTR/WDS(350)
EQUIVALENCE (ST2,ST(2))
IX=I
L=RN(MEDIT)+3
C SIZE OF DELETION
I=IX-L
CALL LOOP(MEDIT,I,1,0,L,RN)
JY=WDS(X22+1)-WDS(X22)
CALL LOOP(WDS(X22)+2,WDS(ITEM),1,0,JY,ST)
K=X22
194 N=K+1
WDS(N)=WDS(N+1)-JY
PWDS(K)=PWDS(N)-L
K=N
IF(K.LT.ITEM)GO TO 194
C ABOVE RESHUFFLES POINTER ARRAYS. X=ITEM+1
ITEM=ITEM-1
IF(X22.GT.ITEM)X22=ITEM
J2=ITEM
ITEM=ITEM-1
ST2=WDS(J2)
271 CALL DPYNEW
END
SUBROUTINE STFCH
CALL CPYIT(1)
END
SUBROUTINE COPYIT
CALL CPYIT(0)
END
C******* PUT THIS INTO CPYIT*******************
C******* PUT THIS INTO CPYIT*******************
CX MOVE 10,.COMM.+7 ;IF(R6.NE.0.AND.R6.NE.RN(L+1))GO TO 1
CX JUMPE 10,CP3 ;IS THERE A CODE NUM IN R6?
CX CAME 10,XRN(11) ;YES. IS THIS THE SAME?
CX JRST CPY ;NO
CX CP4: SKIPN 12,.COMM.+2 ;IF(CENTR.EQ.0)GO TO CP3
CX JRST CP3
CX CAMN 12,[100.0] ;CC=CNTR
CX SETZ 12, ;IF(CC.EQ.100)CC=0
CX MOVE 10,XRN-1(11) ;IF(RN(L).LT.2)GO TO CPY
CX CAML 10,[2.0] ;*** THIS STUFF FOR HORIZONTAL SLICE WITH MOVE
CX CAME 12,XRN+3(11) ;IF(RN(4).NE.CC)GO TO CPY
CX JRST CPY
CX CP3: JUMPL 13,STF2 ; SKIP OVER FOR STFCH ROUTINE
SUBROUTINE CPYIT(KC)
INTEGER PWDS
COMMON/XRN/RN(1) /POSI/S(8),JJ2,P
COMMON R2,JA,CENTR,J2,RJQ(18),RX6,JR,L,RDIS,VY,JQ(17)
1/PTR/PWDS(1) /LIMIT/LIM,ITEM,LL,I,IX
EQUIVALENCE (R4,RJQ(2)),(R5,RJQ(3)),(R7,RJQ(5))
1,(R6,RJQ(4))
C KC IS FLAG FOR STFCH ROUTINE
IM=ITEM
DO 1 K=1,IM
L=PWDS(K)
IF(RTLINE(L))GO TO 1
IF(OUTLMT(R4,R5,RN(L+3)))GO TO 1
IF(R6.NE.0.AND.R6.NE.RN(L+1))GO TO 1
IF(KC.NE.0)GO TO 2
M=RN(L)+2
CALL LOOP(0,M,1,I,L,RN)
ITEM=ITEM+1
L=PWDS(ITEM)
2 IF(R7.LE.7.)RN(L+2)=R7
IF(KC.EQ.0)GO TO 3
IF(K.LT.JJ2)JJ2=K
GO TO 1
3 IF(ITEM.LT.JJ2)JJ2=ITEM
I=I+M+1
PWDS(ITEM+1)=I
1 CONTINUE
IF(KC.EQ.0)R2=R7
END